home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-03
/
baswiz19.zip
/
BW$BAS.ZIP
/
EVAL.BAS
< prev
next >
Wrap
BASIC Source File
|
1993-01-29
|
11KB
|
396 lines
' +----------------------------------------------------------------------+
' | |
' | BASWIZ Copyright (c) 1990-1993 Thomas G. Hanlin III |
' | |
' | The BASIC Wizard's Library |
' | |
' +----------------------------------------------------------------------+
' ----- These are external routines -----
DECLARE FUNCTION ArcCosS! (Nr AS SINGLE)
DECLARE FUNCTION ArcSinS! (Nr AS SINGLE)
' ----- These are internal routines -----
DECLARE FUNCTION Expr0! (Expr$, ErrCode%)
DECLARE FUNCTION Factor0! (Expr$, ErrCode%)
DECLARE FUNCTION Term0! (Expr$, ErrCode%)
DECLARE FUNCTION IsDigit0% (Expr$)
DECLARE FUNCTION ParensOk0% (Expr$)
DECLARE SUB AddParen0 (Expr$, Posn%, WhichWay%)
DECLARE SUB FixPrecedence0 (Expr$)
' ----- This is the main evaluation routine -----
SUB Evaluate (Expression$, Result!, ErrCode%)
Expr$ = UCASE$(Expression$)
WHILE INSTR(Expr$, " ")
tmp% = INSTR(Expr$, " ")
Expr$ = LEFT$(Expr$, tmp% - 1) + MID$(Expr$, tmp% + 1)
WEND
WHILE INSTR(Expr$, "**")
tmp% = INSTR(Expr$, "**")
Expr$ = LEFT$(Expr$, tmp% - 1) + "^" + MID$(Expr$, tmp% + 2)
WEND
IF LEN(Expr$) THEN
IF ParensOk0%(Expr$) THEN
ErrCode% = 0
FixPrecedence0 Expr$
Result! = Expr0!(Expr$, ErrCode%)
ELSE
ErrCode% = 4
END IF
ELSE
ErrCode% = 8
END IF
END SUB
' ----- This adds parentheses to force evaluation by normal algebraic
' ----- precedence (negation, exponentiation, multiplication and division,
' ----- addition and subtraction)
SUB AddParen0 (Expr$, Posn%, WhichWay%)
P% = Posn%
IF WhichWay% < 0 THEN
Done% = 0
DO
P% = P% - 1
IF P% < 1 THEN
Expr$ = "(" + Expr$
Done% = -1
ELSE
ch$ = MID$(Expr$, P%, 1)
IF INSTR("^*/+-", ch$) THEN
Expr$ = LEFT$(Expr$, P%) + "(" + MID$(Expr$, P% + 1)
Done% = -1
ELSEIF ch$ = ")" THEN
Depth% = 1
DO
P% = P% - 1
IF P% > 0 THEN
ch$ = MID$(Expr$, P%, 1)
IF ch$ = "(" THEN
Depth% = Depth% - 1
ELSEIF ch$ = ")" THEN
Depth% = Depth% + 1
END IF
ELSE
Depth% = 0
END IF
LOOP WHILE Depth%
IF P% < 1 THEN P% = 1
Expr$ = LEFT$(Expr$, P%) + "(" + MID$(Expr$, P% + 1)
Done% = -1
END IF
END IF
LOOP UNTIL Done%
ELSE
Done% = 0
DO
P% = P% + 1
IF P% > LEN(Expr$) THEN
Expr$ = Expr$ + ")"
Done% = -1
ELSE
ch$ = MID$(Expr$, P%, 1)
IF INSTR("^*/+-", ch$) THEN
Expr$ = LEFT$(Expr$, P% - 1) + ")" + MID$(Expr$, P%)
Done% = -1
ELSEIF ch$ = "(" THEN
Depth% = 1
DO
P% = P% + 1
IF P% <= LEN(Expr$) THEN
ch$ = MID$(Expr$, P%, 1)
IF ch$ = ")" THEN
Depth% = Depth% - 1
ELSEIF ch$ = "(" THEN
Depth% = Depth% + 1
END IF
ELSE
Depth% = 0
END IF
LOOP WHILE Depth%
IF P% > LEN(Expr$) THEN P% = LEN(Expr$)
Expr$ = LEFT$(Expr$, P% - 1) + ")" + MID$(Expr$, P%)
Done% = -1
END IF
END IF
LOOP UNTIL Done%
END IF
END SUB
' ----- This is the heart of the expression evaluator.
' ----- It is a recursive function.
FUNCTION Expr0! (Expr$, ErrCode%)
LVal! = Factor0!(Expr$, ErrCode%)
IF ErrCode% = 0 THEN
SELECT CASE LEFT$(Expr$, 1)
CASE "+"
Expr$ = MID$(Expr$, 2)
LVal! = LVal! + Expr0!(Expr$, ErrCode%)
CASE "-"
Expr$ = MID$(Expr$, 2)
LVal! = LVal! - Expr0!(Expr$, ErrCode%)
CASE "*"
Expr$ = MID$(Expr$, 2)
LVal! = LVal! * Expr0!(Expr$, ErrCode%)
CASE "/"
Expr$ = MID$(Expr$, 2)
tmp! = Expr0!(Expr$, ErrCode%)
IF tmp! = 0! THEN
ErrCode% = 9
ELSE
LVal! = LVal! / tmp!
END IF
CASE "^"
Expr$ = MID$(Expr$, 2)
LVal! = LVal! ^ Expr0!(Expr$, ErrCode%)
CASE ")"
Expr$ = MID$(Expr$, 2)
CASE ELSE
END SELECT
END IF
Expr0! = LVal!
END FUNCTION
' ----- A recursive evaluation helper, this gets the leftmost term that
' ----- can be dealt with at this point in the evaluation.
FUNCTION Factor0! (Expr$, ErrCode%)
RVal! = 0!
IF LEFT$(Expr$, 1) = "-" THEN
Negate% = -1
Expr$ = MID$(Expr$, 2)
ELSE
Negate% = 0
END IF
IF LEFT$(Expr$, 1) = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = Expr0!(Expr$, ErrCode%)
ELSE
RVal! = Term0!(Expr$, ErrCode%)
END IF
IF Negate% THEN
Factor0! = -RVal!
ELSE
Factor0! = RVal!
END IF
END FUNCTION
' ----- Since the evaluation function doesn't naturally evaluate expressions
' ----- using algebraic precedence, but does understand parentheses...
' ----- This routine adds parentheses to force the proper precedence.
SUB FixPrecedence0 (Expr$)
Expr$ = "(" + Expr$ + ")"
ex% = 1
DO
ex% = INSTR(ex%, Expr$, "-")
IF ex% THEN
ch% = ASC(MID$(Expr$, ex% - 1, 1))
IF NOT (ch% > 47 AND ch% < 58 OR ch% > 64 AND ch% < 91 OR ch% > 96 AND ch% < 123) THEN
' if not alphanumeric, must be negation-- use top priority
AddParen0 Expr$, ex%, 1
AddParen0 Expr$, ex%, -1
END IF
ex% = ex% + 2
END IF
LOOP WHILE ex%
ex% = 1
DO
ch$ = MID$(Expr$, ex%, 1)
IF ch$ = LCASE$(ch$) THEN
ex% = ex% + 1
ELSE
AddParen0 Expr$, ex%, 1
AddParen0 Expr$, ex%, -1
ex% = ex% + 2
END IF
LOOP UNTIL ex% > LEN(Expr$)
ex% = 1
DO
ch$ = MID$(Expr$, ex%, 1)
IF ch$ = "^" THEN
AddParen0 Expr$, ex%, 1
AddParen0 Expr$, ex%, -1
ex% = ex% + 2
ELSE
ex% = ex% + 1
END IF
LOOP UNTIL ex% > LEN(Expr$)
ex% = 1
DO
ch$ = MID$(Expr$, ex%, 1)
IF ch$ = "*" OR ch$ = "/" THEN
AddParen0 Expr$, ex%, 1
AddParen0 Expr$, ex%, -1
ex% = ex% + 2
ELSE
ex% = ex% + 1
END IF
LOOP UNTIL ex% > LEN(Expr$)
ex% = 1
DO
ch$ = MID$(Expr$, ex%, 1)
IF ch$ = "+" OR ch$ = "-" THEN
AddParen0 Expr$, ex%, 1
AddParen0 Expr$, ex%, -1
ex% = ex% + 2
ELSE
ex% = ex% + 1
END IF
LOOP UNTIL ex% > LEN(Expr$)
Expr$ = MID$(Expr$, 2, LEN(Expr$) - 2)
END SUB
' ----- Determines whether a character may be construed as being numeric.
FUNCTION IsDigit0% (Expr$)
IF LEN(Expr$) THEN
IsDigit0% = (INSTR("0123456789.", LEFT$(Expr$, 1)) > 0)
ELSE
IsDigit0% = 0
END IF
END FUNCTION
' ----- Checks to make sure parentheses are balanced.
FUNCTION ParensOk0% (Expr$)
FOR tmp% = 1 TO LEN(Expr$)
ch$ = MID$(Expr$, tmp%, 1)
IF ch$ = "(" THEN
L% = L% + 1
ELSEIF ch$ = ")" THEN
R% = R% + 1
END IF
NEXT
ParensOk0% = (L% = R%)
END FUNCTION
' ----- This grabs a term from the expression.
FUNCTION Term0! (Expr$, ErrCode%)
RVal! = 0!
ch$ = LEFT$(Expr$, 1)
IF ch$ <> LCASE$(ch$) THEN
TermName$ = ""
DO
TermName$ = TermName$ + ch$
Expr$ = MID$(Expr$, 2)
ch$ = LEFT$(Expr$, 1)
LOOP UNTIL ch$ = LCASE$(ch$)
SELECT CASE TermName$
CASE "ABS"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = ABS(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "ACOS"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = ArcCosS!(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "ASIN"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = ArcSinS!(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "ATAN"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = ATN(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "COS"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = COS(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "FRAC"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = Expr0!(Expr$, ErrCode%)
t$ = STR$(RVal!)
tmp = INSTR(t$, ".")
IF tmp THEN
RVal! = CSNG(VAL(MID$(t$, tmp)))
ELSE
RVal! = 0!
END IF
ELSE
ErrCode% = 1
END IF
CASE "INT"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = INT(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "LOG"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = LOG(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "PI"
RVal! = 3.141593
CASE "SIN"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = SIN(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "SQR"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = SQR(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE "TAN"
IF ch$ = "(" THEN
Expr$ = MID$(Expr$, 2)
RVal! = TAN(Expr0!(Expr$, ErrCode%))
ELSE
ErrCode% = 1
END IF
CASE ELSE
ErrCode% = 3
END SELECT
ELSEIF IsDigit0%(Expr$) THEN
tmp$ = ""
DO WHILE IsDigit0%(Expr$)
tmp$ = tmp$ + LEFT$(Expr$, 1)
Expr$ = MID$(Expr$, 2)
LOOP
RVal! = VAL(tmp$)
ELSE
ErrCode% = 2
END IF
Term0! = RVal!
END FUNCTION